home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD81177242000.psc / Projects / VB / Task List / frmAbout.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  2000-07-25  |  9.5 KB  |  217 lines
  1. VERSION 5.00
  2. Begin VB.Form frmAbout 
  3.    BorderStyle     =   3  'Fixed Dialog
  4.    Caption         =   "About MyApp"
  5.    ClientHeight    =   3555
  6.    ClientLeft      =   2340
  7.    ClientTop       =   1935
  8.    ClientWidth     =   5730
  9.    ClipControls    =   0   'False
  10.    Icon            =   "frmAbout.frx":0000
  11.    LinkTopic       =   "Form2"
  12.    MaxButton       =   0   'False
  13.    MinButton       =   0   'False
  14.    ScaleHeight     =   2453.724
  15.    ScaleMode       =   0  'User
  16.    ScaleWidth      =   5380.766
  17.    ShowInTaskbar   =   0   'False
  18.    Begin VB.PictureBox picIcon 
  19.       AutoSize        =   -1  'True
  20.       BorderStyle     =   0  'None
  21.       ClipControls    =   0   'False
  22.       Height          =   420
  23.       Left            =   240
  24.       Picture         =   "frmAbout.frx":0442
  25.       ScaleHeight     =   294.98
  26.       ScaleMode       =   0  'User
  27.       ScaleWidth      =   294.98
  28.       TabIndex        =   1
  29.       Top             =   225
  30.       Width           =   420
  31.    End
  32.    Begin VB.CommandButton cmdOK 
  33.       Cancel          =   -1  'True
  34.       Caption         =   "OK"
  35.       Default         =   -1  'True
  36.       Height          =   345
  37.       Left            =   4245
  38.       TabIndex        =   0
  39.       Top             =   2625
  40.       Width           =   1260
  41.    End
  42.    Begin VB.CommandButton cmdSysInfo 
  43.       Caption         =   "&System Info..."
  44.       Height          =   345
  45.       Left            =   4260
  46.       TabIndex        =   2
  47.       Top             =   3075
  48.       Width           =   1245
  49.    End
  50.    Begin VB.Line Line1 
  51.       BorderColor     =   &H00808080&
  52.       BorderStyle     =   6  'Inside Solid
  53.       Index           =   1
  54.       X1              =   84.515
  55.       X2              =   5309.398
  56.       Y1              =   1687.583
  57.       Y2              =   1687.583
  58.    End
  59.    Begin VB.Label lblDescription 
  60.       Caption         =   $"frmAbout.frx":0DB4
  61.       ForeColor       =   &H00000000&
  62.       Height          =   1170
  63.       Left            =   1050
  64.       TabIndex        =   3
  65.       Top             =   1125
  66.       Width           =   4425
  67.    End
  68.    Begin VB.Label lblTitle 
  69.       BackStyle       =   0  'Transparent
  70.       Caption         =   "Application Title"
  71.       ForeColor       =   &H00000000&
  72.       Height          =   480
  73.       Left            =   1050
  74.       TabIndex        =   5
  75.       Top             =   240
  76.       Width           =   3885
  77.    End
  78.    Begin VB.Line Line1 
  79.       BorderColor     =   &H00FFFFFF&
  80.       BorderWidth     =   2
  81.       Index           =   0
  82.       X1              =   98.6
  83.       X2              =   5309.398
  84.       Y1              =   1697.936
  85.       Y2              =   1697.936
  86.    End
  87.    Begin VB.Label lblVersion 
  88.       Caption         =   "Version"
  89.       Height          =   225
  90.       Left            =   1050
  91.       TabIndex        =   6
  92.       Top             =   780
  93.       Width           =   3885
  94.    End
  95.    Begin VB.Label lblDisclaimer 
  96.       Caption         =   "Warning: ... No Warranty, distributed AS IS.  This product is not supported!"
  97.       ForeColor       =   &H00000000&
  98.       Height          =   825
  99.       Left            =   255
  100.       TabIndex        =   4
  101.       Top             =   2610
  102.       Width           =   3870
  103.    End
  104. Attribute VB_Name = "frmAbout"
  105. Attribute VB_GlobalNameSpace = False
  106. Attribute VB_Creatable = False
  107. Attribute VB_PredeclaredId = True
  108. Attribute VB_Exposed = False
  109. Option Explicit
  110. '--Reg Key Security Options...
  111. Const READ_CONTROL = &H20000
  112. Const KEY_QUERY_VALUE = &H1
  113. Const KEY_SET_VALUE = &H2
  114. Const KEY_CREATE_SUB_KEY = &H4
  115. Const KEY_ENUMERATE_SUB_KEYS = &H8
  116. Const KEY_NOTIFY = &H10
  117. Const KEY_CREATE_LINK = &H20
  118. Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + _
  119.                        KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + _
  120.                        KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL
  121.                      
  122. '--Reg Key ROOT Types...
  123. Const HKEY_LOCAL_MACHINE = &H80000002
  124. Const ERROR_SUCCESS = 0
  125. Const REG_SZ = 1                         '--Unicode nul terminated string
  126. Const REG_DWORD = 4                      '--32-bit number
  127. Const gREGKEYSYSINFOLOC = "SOFTWARE\Microsoft\Shared Tools Location"
  128. Const gREGVALSYSINFOLOC = "MSINFO"
  129. Const gREGKEYSYSINFO = "SOFTWARE\Microsoft\Shared Tools\MSINFO"
  130. Const gREGVALSYSINFO = "strPath"
  131. Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
  132. Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long
  133. Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
  134. Private Sub cmdSysInfo_Click()
  135.    Call StartSysInfo
  136. End Sub
  137. Private Sub cmdOK_Click()
  138.    Unload Me
  139. End Sub
  140. Private Sub Form_Load()
  141.    Me.Caption = "About " & App.Title
  142.    lblVersion.Caption = "Version " & App.Major & "." & App.Minor & "." & App.Revision
  143.    lblTitle.Caption = App.Title
  144. End Sub
  145. Public Sub StartSysInfo()
  146.    On Error GoTo SysInfoErr
  147.    Dim rc As Long
  148.    Dim SysInfoPath As String
  149.    '--Try To Get System Info Program strPath\Name From Registry...
  150.    If GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFO, gREGVALSYSINFO, SysInfoPath) Then
  151.    '--Try To Get System Info Program strPath Only From Registry...
  152.    ElseIf GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFOLOC, gREGVALSYSINFOLOC, SysInfoPath) Then
  153.       '--Validate Existance Of Known 32 Bit File Version
  154.       If (Dir(SysInfoPath & "\MSINFO32.EXE") <> "") Then
  155.           SysInfoPath = SysInfoPath & "\MSINFO32.EXE"
  156.           
  157.       '--Error - File Can Not Be Found...
  158.       Else
  159.           GoTo SysInfoErr
  160.       End If
  161.    '--Error - Registry Entry Can Not Be Found...
  162.    Else
  163.       GoTo SysInfoErr
  164.    End If
  165.    Call Shell(SysInfoPath, vbNormalFocus)
  166.    Exit Sub
  167. SysInfoErr:
  168.     MsgBox "System Information Is Unavailable At This Time", vbOKOnly
  169. End Sub
  170. Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String, ByRef KeyVal As String) As Boolean
  171.    Dim i As Long                                           '--Loop Counter
  172.    Dim rc As Long                                          '--Return Code
  173.    Dim hKey As Long                                        '--Handle To An Open Registry Key
  174.    Dim hDepth As Long                                      '
  175.    Dim KeyValType As Long                                  '--Data Type Of A Registry Key
  176.    Dim tmpVal As String                                    '--Tempory Storage For A Registry Key Value
  177.    Dim KeyValSize As Long                                  '--Size Of Registry Key Variable
  178.    '------------------------------------------------------------
  179.    '--Open RegKey Under KeyRoot {HKEY_LOCAL_MACHINE...}
  180.    '------------------------------------------------------------
  181.    rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) '--Open Registry Key
  182.    If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          '--Handle Error...
  183.    tmpVal = String$(1024, 0)                             '--Allocate Variable Space
  184.    KeyValSize = 1024                                       '--Mark Variable Size
  185.    '------------------------------------------------------------
  186.    '--Retrieve Registry Key Value...
  187.    '------------------------------------------------------------
  188.    rc = RegQueryValueEx(hKey, SubKeyRef, 0, _
  189.                         KeyValType, tmpVal, KeyValSize)    '--Get/Create Key Value
  190.                        
  191.    If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          '--Handle Errors
  192.    If (Asc(Mid(tmpVal, KeyValSize, 1)) = 0) Then           '--Win95 Adds Null Terminated String...
  193.       tmpVal = Left(tmpVal, KeyValSize - 1)               '--Null Found, Extract From String
  194.    Else                                                    '--WinNT Does NOT Null Terminate String...
  195.        tmpVal = Left(tmpVal, KeyValSize)                   '--Null Not Found, Extract String Only
  196.    End If
  197.    '------------------------------------------------------------
  198.    '--Determine Key Value Type For Conversion...
  199.    '------------------------------------------------------------
  200.    Select Case KeyValType                                  '--Search Data Types...
  201.    Case REG_SZ                                             '--String Registry Key Data Type
  202.       KeyVal = tmpVal                                     '--Copy String Value
  203.    Case REG_DWORD                                          '--Double Word Registry Key Data Type
  204.       For i = Len(tmpVal) To 1 Step -1                    '--Convert Each Bit
  205.           KeyVal = KeyVal + Hex(Asc(Mid(tmpVal, i, 1)))   '--Build Value Char. By Char.
  206.       Next
  207.       KeyVal = Format$("&h" + KeyVal)                     '--Convert Double Word To String
  208.    End Select
  209.    GetKeyValue = True                                      '--Return Success
  210.    rc = RegCloseKey(hKey)                                  '--Close Registry Key
  211.    Exit Function                                           '--Exit
  212. GetKeyError:      '--Cleanup After An Error Has Occured...
  213.    KeyVal = ""                                             '--Set Return Val To Empty String
  214.    GetKeyValue = False                                     '--Return Failure
  215.    rc = RegCloseKey(hKey)                                  '--Close Registry Key
  216. End Function
  217.